home *** CD-ROM | disk | FTP | other *** search
/ Windows Expert / Windows Expert.iso / program / blx13.zip / PASENG.ZIP / PXDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1991-03-08  |  13KB  |  438 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Paradox Engine demo program                  }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program PXDemo;
  10.  
  11. {$R PXDEMO.RES}
  12. {$N+}
  13.  
  14. uses WObjects, WinTypes, WinProcs, Strings, StdDlgs, PXEngine, PXAccess;
  15.  
  16. const
  17.   BKColor   = $00FFFF00;
  18.   ForeColor = $00000000;
  19.  
  20. const
  21.   cm_FileClose = 100;
  22.  
  23. const
  24.   MenuID      = 100;
  25.   IconID      = 100;
  26.  
  27. type
  28.   TParadoxDemo = object(TApplication)
  29.     destructor Done; virtual;
  30.     procedure InitMainWindow; virtual;
  31.     procedure Error(errorCode: Integer); virtual;
  32.   end;
  33.  
  34.   PParadoxTableWindow = ^TParadoxTableWindow;
  35.   TParadoxTableWindow = object(TWindow)
  36.     CharWidth: Integer;
  37.     CharHeight: Integer;
  38.     TableWidth: Integer;
  39.     NumFields: Integer;
  40.     FixedFont: HFont;
  41.     Table: PPXTable;
  42.     FieldStarts: PWordArray;
  43.     TitleBar: HBitmap;
  44.     ColumnBar: HBitmap;
  45.     constructor Init(AParent: PWindowsObject; TableName: PChar);
  46.     destructor Done; virtual;
  47.     procedure CheckTable;
  48.     procedure CloseTable;
  49.     function GetClassName: PChar; virtual;
  50.     procedure GetFixedFont(DC: HDC);
  51.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  52.     procedure Paint(DC: HDC; var PS: TPaintStruct); virtual;
  53.     procedure RecordTitleBar;
  54.     procedure SetupWindow; virtual;
  55.     procedure CMFileClose(var Message: TMessage);
  56.       virtual cm_First + cm_FileClose;
  57.     procedure CMFileOpen(var Message: TMessage);
  58.       virtual cm_First + cm_FileOpen;
  59.     procedure WMKeyDown(var Msg: TMessage);
  60.       virtual wm_First + wm_KeyDown;
  61.     procedure WMSize(var Msg: TMessage);
  62.       virtual wm_First + wm_Size;
  63.     procedure WMTimer(var Msg: TMessage);
  64.       virtual wm_First + wm_Timer;
  65.   end;
  66.  
  67. { TParadoxDemo }
  68.  
  69. destructor TParadoxDemo.Done;
  70. begin
  71.   TApplication.Done;
  72.   PXExit;
  73. end;
  74.  
  75. procedure TParadoxDemo.InitMainWindow;
  76. begin
  77.   Status := PXWinInit('PXDemo', PXShared);
  78.   if Status = PXSuccess then
  79.     MainWindow := New(PParadoxTableWindow, Init(nil, 'Paradox Table Viewer'))
  80.   else MessageBox(0, PXErrMsg(Status), 'PXDemo', mb_OK)
  81. end;
  82.  
  83. procedure TParadoxDemo.Error(ErrorCode: Integer);
  84. begin
  85.   if Status < 0 then TApplication.Error(ErrorCode)
  86.   else MessageBox(GetFocus, PXErrMsg(Status), 'WinTable', MB_OK);
  87. end;
  88.  
  89. { TParadoxTableWindow }
  90.  
  91. constructor TParadoxTableWindow.Init(AParent: PWindowsObject;
  92.   TableName: PChar);
  93. begin
  94.   TWindow.Init(AParent, TableName);
  95.   with Attr do
  96.   begin
  97.     Menu := LoadMenu(HInstance, MakeIntResource(MenuID));
  98.     Style := Style or ws_VScroll or ws_HScroll;
  99.     X := 25;
  100.     Y := 40;
  101.     W := 500;
  102.     H := 350;
  103.   end;
  104.   Scroller := New(PScroller, Init(@Self, 1, 1, 0, 0));
  105.   Scroller^.TrackMode := False;
  106.   Scroller^.AutoOrg := False;
  107.   Table := nil;
  108.   FieldStarts := nil;
  109.   TitleBar := 0;
  110.   ColumnBar := 0;
  111. end;
  112.  
  113. destructor TParadoxTableWindow.Done;
  114. begin
  115.   CloseTable;
  116.   TWindow.Done;
  117. end;
  118.  
  119. procedure TParadoxTableWindow.CheckTable;
  120. begin
  121.   if Table <> nil then
  122.     if Table^.Update then
  123.       RecordTitleBar;
  124. end;
  125.  
  126. procedure TParadoxTableWindow.CloseTable;
  127. begin
  128.   if Table <> nil then
  129.   begin
  130.     FreeMem(FieldStarts, SizeOf(Word) * (Table^.NumFields + 2));
  131.     FieldStarts := nil;
  132.     DeleteObject(TitleBar);
  133.     TitleBar := 0;
  134.     Dispose(Table, Done);
  135.     Table := nil;
  136.     InvalidateRect(HWindow, nil, True);
  137.   end;
  138. end;
  139.  
  140. procedure TParadoxTableWindow.CMFileClose(var Message: TMessage);
  141. begin
  142.   CloseTable;
  143. end;
  144.  
  145. procedure TParadoxTableWindow.CMFileOpen(var Message: TMessage);
  146. var
  147.   Filename: array[0..128] of Char;
  148. begin
  149.   if Application^.ExecDialog(New(PFileDialog, Init(@Self, PChar(sd_FileOpen),
  150.     StrCopy(FileName, '*.db')))) = idOK then
  151.   begin
  152.     CloseTable;
  153.     Table := New(PPXTable, Init(FileName));
  154.     if Table^.Status <> 0 then
  155.     begin
  156.       Dispose(Table, Done);
  157.       Table := nil;
  158.     end
  159.     else RecordTitleBar;
  160.   end;
  161. end;
  162.  
  163.  
  164. procedure TParadoxTableWindow.RecordTitleBar;
  165. var
  166.   I, J: Integer;
  167.   R: TRect;
  168.   DC, MemDC: HDC;
  169.   OldBrush: HBrush;
  170.   OldPen: HPen;
  171.   SepX, SepY, TitleWidth: Integer;
  172.   CurField: Integer;
  173.   FieldStart, FieldEnd: Integer;
  174.  
  175. function Min(X,Y: Integer): Integer;
  176. begin
  177.   if X < Y then Min := X else Min := Y;
  178. end;
  179.  
  180. begin
  181.   { Record Field starts }
  182.   if FieldStarts <> nil then
  183.     FreeMem(FieldStarts, SizeOf(Word) * NumFields + 2);
  184.   NumFields := Table^.NumFields;
  185.   GetMem(FieldStarts, SizeOf(Word) * NumFields + 2);
  186.   J := 0;
  187.   FieldStarts^[1] := 0;
  188.   for I := 2 to Table^.NumFields + 1 do
  189.     FieldStarts^[I] := Table^.FieldWidth(I - 1) + FieldStarts^[I - 1] + 1;
  190.   TableWidth := FieldStarts^[I];
  191.   GetClientRect(HWindow, R);
  192.   Scroller^.SetRange(TableWidth - R.right div CharWidth,
  193.     Table^.NumRecords - R.bottom div CharHeight);
  194.  
  195.   { Create the title bar bitmap }
  196.   if TitleBar <> 0 then DeleteObject(TitleBar);
  197.   DC := GetDC(HWindow);
  198.   MemDC := CreateCompatibleDC(DC);
  199.   ReleaseDC(HWindow, DC);
  200.   TitleWidth := TableWidth * CharWidth;
  201.   TitleBar := CreateCompatibleBitmap(DC, TitleWidth, CharHeight);
  202.   SelectObject(MemDC, TitleBar);
  203.   SelectObject(MemDC, FixedFont);
  204.   SetTextColor(MemDC, ForeColor);
  205.   SetBkColor(MemDC, BKColor);
  206.   OldBrush := SelectObject(MemDC, CreateSolidBrush(BKColor));
  207.   PatBlt(MemDC, 0, 0, TitleWidth, CharHeight, PatCopy);
  208.   DeleteObject(SelectObject(MemDC, OldBrush));
  209.  
  210.   { Draw double lines }
  211.   OldPen := SelectObject(MemDC, CreatePen(ps_Solid, 2, ForeColor));
  212.   SepX := CharWidth div 3;
  213.   SepY := CharHeight div 3;
  214.   {   Top line }
  215.   MoveTo(MemDC, SepX, SepY);
  216.   LineTo(MemDC, TitleWidth - SepX, SepY);
  217.   LineTo(MemDC, TitleWidth - SepX, CharHeight + 1);
  218.   {   Bottom lines and titles}
  219.   Inc(SepY, SepY);
  220.   for I := 1 to  Table^.NumFields do
  221.   begin
  222.     FieldStart := FieldStarts^[I] * CharWidth;
  223.     FieldEnd := FieldStart + Table^.FieldWidth(I) * CharWidth;
  224.     MoveTo(MemDC, FieldStart - SepX, CharHeight);
  225.     LineTo(MemDC, FieldStart - SepX, SepY);
  226.     LineTo(MemDC, FieldEnd + SepX, SepY);
  227.     LineTo(MemDC, FieldEnd + SepX, CharHeight + 1);
  228.     TextOut(MemDC, FieldStart, 0, Table^.FieldName(I),
  229.       Min(StrLen(Table^.FieldName(I)), Table^.FieldWidth(I)));
  230.   end;
  231.   DeleteObject(SelectObject(MemDC, OldPen));
  232.   DeleteDC(MemDC);
  233.   InvalidateRect(HWindow, nil, False);
  234. end;
  235.  
  236. function TParadoxTableWindow.GetClassName: PChar;
  237. begin
  238.   GetClassName := 'TurboTableView';
  239. end;
  240.  
  241. function EnumerateFont(LogFont: PLogFont; TextMetric: PTextMetric;
  242.   FontType: Integer; Data: Pointer): Bool; export;
  243. begin
  244.   PLogFont(Data)^ := LogFont^;
  245.   EnumerateFont := (TextMetric^.tmPitchAndFamily and 1) = 1;
  246. end;
  247.  
  248. procedure TParadoxTableWindow.GetFixedFont(DC: HDC);
  249. var
  250.   LogFont: TLogFont;
  251.   FontFunc: TFarProc;
  252. begin
  253.   FontFunc := MakeProcInstance(@EnumerateFont, HInstance);
  254.   EnumFonts(DC, 'SYSTEM', FontFunc, @LogFont);
  255.   FixedFont := CreateFontIndirect(LogFont);
  256.   FreeProcInstance(FontFunc);
  257. end;
  258.  
  259. procedure TParadoxTableWindow.GetWindowClass(var WndClass: TWndClass);
  260. var
  261.   LogBrush: TLogBrush;
  262. begin
  263.   TWindow.GetWindowClass(WndClass);
  264.   LogBrush.lbStyle := bs_Solid;
  265.   LogBrush.lbColor := BKColor;
  266.   WndClass.hbrBackground := CreateBrushIndirect(LogBrush);
  267.   WndClass.hIcon := LoadIcon(HInstance, MakeIntResource(IconID));
  268. end;
  269.  
  270. procedure TParadoxTableWindow.Paint(DC: HDC; var PS: TPaintStruct);
  271. var
  272.   OldFont: HFont;
  273.   OldCursor: HCursor;
  274.   HRgn1, HRgn2: HRgn;
  275.   MemDC: HDC;
  276.   StartX, StopX: Integer;
  277.   FirstField, LastField, FirstRec, LastRec: Integer;
  278.   I, J: Integer;
  279.   R: TRect;
  280.  
  281. procedure DrawField(X, Y, Width: Integer; FieldText: PChar);
  282. var
  283.   Temp: array[0..255] of Char;
  284.   XPos, YPos, Len: Integer;
  285.   R: TRect;
  286. begin
  287.   XPos := (X - Scroller^.XPos) * CharWidth;
  288.   YPos := (Y - Scroller^.YPos) * CharHeight;
  289.   Len := StrLen(FieldText);
  290.   TextOut(DC, XPos, YPos, FieldText, Len);
  291.   if Width > Len then
  292.   begin
  293.     FillChar(Temp, SizeOf(Temp), ' ');
  294.     TextOut(DC, XPos + Len * CharWidth, YPos, Temp, Width - Len);
  295.   end;
  296. end;
  297.  
  298. begin
  299.   if Table <> nil then
  300.   begin
  301.     CheckTable;
  302.     SetTextColor(DC, ForeColor);
  303.     SetBkColor(DC, BKColor);
  304.     OldFont := SelectObject(DC, FixedFont);
  305.     StartX := (PS.rcPaint.left div CharWidth) + Scroller^.XPos;
  306.     StopX := (PS.rcPaint.right div CharWidth + 1) + Scroller^.XPos;
  307.     FirstField := 1;
  308.     while FieldStarts^[FirstField+1] <= StartX do Inc(FirstField);
  309.     LastField := Table^.NumFields;
  310.     while FieldStarts^[LastField] >= StopX do Dec(LastField);
  311.     FirstRec := (PS.rcPaint.top div CharHeight) + Scroller^.YPos;
  312.     LastRec := (PS.rcPaint.bottom div CharHeight + 1) + Scroller^.YPos + 1;
  313.     MemDC := CreateCompatibleDC(DC);
  314.     SelectObject(MemDC, ColumnBar);
  315.     for I := FirstField to LastField do
  316.     begin
  317.       J := (FieldStarts^[I + 1] - Scroller^.XPos - 1) * CharWidth;
  318.       BitBlt(DC, J, PS.rcPaint.top, J + CharWidth, PS.rcPaint.bottom,
  319.     MemDC, 0, 0, SrcCopy);
  320.     end;
  321.     DeleteDC(MemDC);
  322.     OldCursor := SetCursor(LoadCursor(0, idc_Wait));
  323.  
  324.     for I := FirstRec to LastRec do
  325.       if I = 0 then
  326.       begin
  327.     MemDC := CreateCompatibleDC(DC);
  328.     SelectObject(MemDC, TitleBar);
  329.     BitBlt(DC, 0, 0, (TableWidth - Scroller^.XPos) * CharWidth,
  330.       CharHeight, MemDC, Scroller^.XPos * CharWidth, 0, SrcCopy);
  331.     DeleteDC(MemDC);
  332.       end
  333.       else
  334.     for J := FirstField to LastField do
  335.       DrawField(FieldStarts^[J], I, Table^.FieldWidth(J),
  336.         Table^.GetField(I, J));
  337.     SetCursor(OldCursor);
  338.     SelectObject(DC, OldFont);
  339.     if Table^.Status <> 0 then CloseTable;
  340.   end;
  341. end;
  342.  
  343. procedure TParadoxTableWindow.SetupWindow;
  344. var
  345.   TextMetric: TTextMetric;
  346.   DC: HDC;
  347.   OldFont: THandle;
  348. begin
  349.   TWindow.SetupWindow;
  350.   DC := GetDC(HWindow);
  351.   GetFixedFont(DC);
  352.   OldFont := SelectObject(DC, FixedFont);
  353.   GetTextMetrics(DC, TextMetric);
  354.   CharWidth := TextMetric.tmAveCharWidth;
  355.   CharHeight := TextMetric.tmHeight;
  356.   Scroller^.SetUnits(CharWidth, CharHeight);
  357.   SelectObject(DC, OldFont);
  358.   ReleaseDC(HWindow, DC);
  359.   Scroller^.SetSBarRange;
  360.   SetTimer(HWindow, 0, 3000, nil);
  361. end;
  362.  
  363. procedure TParadoxTableWindow.WMKeyDown(var Msg: TMessage);
  364. begin
  365.   with Scroller^ do
  366.     case Msg.wParam of
  367.       vk_Left:
  368.     if GetKeyState(vk_Control) and $8000 <> 0 then
  369.           HScroll(sb_PageUp, 0)
  370.         else
  371.           HScroll(sb_LineUp, 0);
  372.       vk_Right:
  373.         if GetKeyState(vk_Control) and $8000 <> 0 then
  374.       HScroll(sb_PageDown, 0)
  375.         else
  376.       HScroll(sb_LineDown, 0);
  377.       vk_Up: VScroll(sb_LineUp, 0);
  378.       vk_Down: VScroll(sb_LineDown, 0);
  379.       vk_Next: VScroll(sb_PageDown, 0);
  380.       vk_Prior: VScroll(sb_PageUp, 0);
  381.       vk_Home: ScrollTo(XPos, 0);
  382.       vk_End: ScrollTo(XPos, Table^.NumRecords);
  383.     end;
  384. end;
  385.  
  386. procedure TParadoxTableWindow.WMSize(var Msg: TMessage);
  387. var
  388.   R: TRect;
  389.   DC, MemDC: HDC;
  390.   OldBrush: HBrush;
  391.   OldPen: HPen;
  392.   SepX: Integer;
  393. begin
  394.   TWindow.WMSize(Msg);
  395.   if Table <> nil then
  396.   begin
  397.     GetClientRect(HWindow, R);
  398.     Scroller^.SetRange(TableWidth - R.right div CharWidth,
  399.       Table^.NumRecords - R.bottom div CharHeight + 1);
  400.     { Call GetClientRect again because SetRange can change the size of
  401.       the client area if a scrollbar disappears }
  402.     GetClientRect(HWindow, R);
  403.     if ColumnBar <> 0 then DeleteObject(ColumnBar);
  404.     DC := GetDC(HWindow);
  405.     MemDC := CreateCompatibleDC(DC);
  406.     ReleaseDC(HWindow, DC);
  407.     ColumnBar := CreateCompatibleBitmap(DC, CharWidth,
  408.       R.bottom * CharHeight);
  409.     SelectObject(MemDC, ColumnBar);
  410.     SetTextColor(MemDC, ForeColor);
  411.     SetBKColor(MemDC, BKColor);
  412.     OldBrush := SelectObject(MemDC, CreateSolidBrush(BKColor));
  413.     PatBlt(MemDC, 0, 0, CharWidth, R.bottom * CharHeight, PatCopy);
  414.     DeleteObject(SelectObject(MemDC, OldBrush));
  415.     OldPen := SelectObject(MemDC, CreatePen(ps_Solid, 2, ForeColor));
  416.     SepX := CharWidth div 3;
  417.     MoveTo(MemDC, SepX, 0);
  418.     LineTo(MemDC, SepX, R.bottom);
  419.     MoveTo(MemDC, CharWidth - SepX, 0);
  420.     LineTo(MemDC, CharWidth - SepX, R.bottom);
  421.     DeleteObject(SelectObject(MemDC, OldPen));
  422.     DeleteDC(MemDC);
  423.   end;
  424. end;
  425.  
  426. procedure TParadoxTableWindow.WMTimer(var Msg: TMessage);
  427. begin
  428.   CheckTable;
  429. end;
  430.  
  431. var
  432.   ParadoxDemo: TParadoxDemo;
  433. begin
  434.   ParadoxDemo.Init('ParadoxDemo');
  435.   ParadoxDemo.Run;
  436.   ParadoxDemo.Done;
  437. end.
  438.